home *** CD-ROM | disk | FTP | other *** search
/ Fritz: All Fritz / All Fritz.zip / All Fritz / FILES / PROGMISC / FORTRAN2.LZH / NAE.FOR < prev    next >
Encoding:
Text File  |  1988-02-08  |  10.5 KB  |  356 lines
  1.       SUBROUTINE NAE ( NREAD, NWRITE, NUM, MAX, IARRAY, ERROR )
  2. C*
  3. C*                  *******************************
  4. C*                  *******************************
  5. C*                  **                           **
  6. C*                  **          NAE              **
  7. C*                  **                           **
  8. C*                  *******************************
  9. C*                  *******************************
  10. C*
  11. C*     SUBPROGRAM :
  12. C*          NIFTY ARRAY EDITOR
  13. C*
  14. C*     AUTHOR :
  15. C*          ART RAGOSTA
  16. C*          MS 207-5
  17. C*          AMES RESEARCH CENTER
  18. C*          MOFFETT FIELD, CALIF  94035
  19. C*          (415) 694-5578
  20. C*
  21. C*     PURPOSE :
  22. C*          TO ENABLE THE SCREEN-ORIENTED EDITING OF 1 TO 3 ARRAYS.
  23. C*
  24. C*     METHODOLOGY :
  25. C*          USES DEC RUN TIME LIBRARY CALLS FOR SCREEN MANIPULATION.
  26. C*
  27. C*     INPUT ARGUMENTS :
  28. C*          NREAD  - KEYBOARD LOGICAL UNIT NUMBER.
  29. C*          NWRITE - SCREEN LOGICAL UNIT NUMBER.
  30. C*          NUM    - NUMBER OF ELEMENTS IN ARRAYS.
  31. C*          MAX    - THE DIMENSION OF ARRAYS.
  32. C*          IARRAY - THE FIRST DATA ARRAY.
  33. C*
  34. C*     OUTPUT ARGUMENTS :
  35. C*          ERROR  - .TRUE. IF AN UNRECOVERABLE ERROR WAS ENCOUNTERED.
  36. C*
  37. C*     INTERNAL WORK AREAS :
  38. C*          STRING - TEMPORARY STORAGE FOR INPUT STRING.
  39. C*
  40. C*     COMMON BLOCKS :
  41. C*          NONE
  42. C*
  43. C*     FILE REFERENCES :
  44. C*          NREAD, NWRITE
  45. C*
  46. C*     DATA BASE ACCESS :
  47. C*          NONE
  48. C*
  49. C*     SUBPROGRAM REFERENCES :
  50. C*          CLEAR,  NSTAT,  WRITA,  GOTOXY,  CAPS,   LEFT,  MBELL
  51. C*          STAT,   WAIT,   WRITL,  REVLF,   GETOKE, RIGHT, SRESET
  52. C*
  53. C*     ERROR PROCESSING :
  54. C*          CHECK FOR VALID COMMANDS.
  55. C*          CHECK FOR RIGHT NUMBER OF ENTRIES ON A LINE.
  56. C*
  57. C*     TRANSPORTABILITY LIMITATIONS :
  58. C*          NOT TRANSPORTABLE.
  59. C*
  60. C*     ASSUMPTIONS AND RESTRICTIONS :
  61. C*          VT-100 COMPATIBLE TERMINALS ONLY.
  62. C*
  63. C*     LANGUAGE AND COMPILER :
  64. C*          ANSI FORTRAN 77
  65. C*
  66. C*     VERSION AND DATE :
  67. C*          VERSION I.0      4-FEB-85
  68. C*
  69. C*     CHANGE HISTORY :
  70. C*           4-FEB-85    INITIAL VERSION
  71. C*
  72. C***********************************************************************
  73. C*
  74.       CHARACTER *80 STRING
  75.       CHARACTER *20 TOKE
  76.       CHARACTER *1 ESC, TYPE
  77.       LOGICAL ERROR, DOWN, ERR
  78.       DIMENSION IARRAY(MAX)
  79.       DATA ESC/27/
  80. C
  81. C  NUM    - THE NUMBER OF ELEMENTS IN IARRAY
  82. C  MAX    - THE MAXIMUM DIMENSION OF IARRAY
  83. C  IARRAY - THE DATA TO BE EDITED
  84. C  NARRAY - THE NUMBER OF ARRAYS ( 1 FOR THIS VERSION )
  85. C  ERROR  - INTERNAL ERROR FLAG
  86. C  DOWN   - .TRUE. IF THE DEFAULT DIRECTION IS DOWN
  87. C  IPTR   - THE ARRAY ELEMENT WE ARE PRESENTLY POINTING TO
  88. C  IX     - X LOCATION OF CURSOR (ALWAYS 1 IN PRESENT VERSION)
  89. C  IY     - Y LOCATION OF CURSOR (BETWEEN 2 AND 24)
  90. C  NREAD  - KEYBOARD UNIT NUMBER
  91. C  NWRITE - SCREEN UNIT NUMBER
  92. C  STRING - INPUT BUFFER
  93. C  ISTART - THE FIRST ELEMENT IN THE ARRAY TO BE DISPLAYED ON THE SCREEN
  94. C
  95.       GO TO 50
  96.       ENTRY NAE1 ( NREAD, NWRITE, NUM, MAX, IARRAY, ERROR )
  97. 50    CALL CLEAR
  98.       ERROR  = .FALSE.
  99.       IF ( NUM .GT. MAX ) THEN
  100.          ERROR = .TRUE.
  101.          RETURN
  102.       ENDIF
  103.       NARRAY = 1
  104.       DOWN   = .TRUE.
  105.       IX     = 1
  106.       IY     = 2
  107. C
  108. C --- DISPLAY INITIAL STATUS, DISPLAY FIRST PART OF ARRAYS
  109. C
  110.       IPTR = 0
  111.       IF ( NUM .GE. 1 ) IPTR = 1
  112.       ISTART = IPTR
  113.       CALL NSTAT ( IX, IY, NUM, DOWN )
  114.       CALL WRITA ( NWRITE, NUM, IARRAY, ISTART )
  115.       CALL GOTOXY ( NWRITE, IX, IY )
  116. C
  117. C --- REPEAT UNTIL DONE
  118. C
  119. 100   READ ( NREAD, 900, END=1000, ERR=1000 ) STRING
  120.       CALL CAPS ( STRING )
  121.       CALL LEFT ( STRING )
  122.       IF (STRING(1:1) .EQ. 'A') THEN
  123. C
  124. C ----- 'ADD' COMMAND
  125. C
  126.          IF (NUM .EQ. MAX) THEN
  127.             CALL MBELL ( NWRITE )
  128.             CALL STAT ( IX, IY, ' Arrays full, insert ignored. ' )
  129.             CALL WAIT ( 3 )
  130.             CALL NSTAT ( IX, IY, NUM, DOWN )
  131.          ELSE
  132.             IARRAY(NUM+1) = 0
  133.             NUM    = NUM + 1
  134.             CALL NSTAT ( IX, IY, NUM, DOWN )
  135.             ISTART = MAX0(NUM-21,1)
  136.             IF (NUM .EQ. 0 )ISTART = 0
  137.             CALL WRITA ( NWRITE, NUM, IARRAY, ISTART )
  138.             IPTR   = NUM
  139.             IY     = MIN0 ( NUM+1, 23 )
  140.             IF (NUM .EQ. 0) IY = 2
  141.             CALL GOTOXY ( NWRITE, IX, IY )
  142.          ENDIF
  143.       ELSE IF (STRING(1:1) .EQ. 'B') THEN
  144. C
  145. C ----- 'BEGIN' COMMAND
  146. C
  147.          IPTR   = 0
  148.          IF (NUM .GE. 1) IPTR = 1
  149.          ISTART = IPTR
  150.          CALL WRITA ( NWRITE, NUM, IARRAY, ISTART )
  151.          IY     = 2
  152.          CALL GOTOXY ( NWRITE, IX, IY )
  153. C
  154.       ELSE IF (STRING(1:1) .EQ. 'D') THEN
  155. C
  156. C ----- 'DELETE' COMMAND
  157. C
  158.          IF (NUM .GT. 0) THEN
  159.             NUM = NUM - 1
  160.             IF (IPTR .EQ. NUM+1) THEN
  161.                IPTR = NUM
  162.                ISTART = ISTART - 1
  163.                IF ( ISTART .LE. 0 ) THEN
  164.                   ISTART = 1
  165.                   IY = IY - 1
  166.                ENDIF
  167.             ELSE
  168.                DO 110 II = IPTR, NUM
  169.                   IARRAY(II) = IARRAY(II+1)
  170. 110               CONTINUE
  171.                IF ( ISTART+22 .GT. NUM )ISTART = ISTART - 1
  172.                IF ( ISTART .LE. 0 )ISTART = 1
  173.             ENDIF
  174.             IF (NUM .EQ. 0) THEN
  175.                ISTART = 0
  176.                IY = 2
  177.             ENDIF
  178.             CALL NSTAT ( IX, IY, NUM, DOWN )
  179.             CALL WRITA ( NWRITE, NUM, IARRAY, ISTART )
  180.          ENDIF
  181.          CALL GOTOXY ( NWRITE, IX, IY )
  182. C
  183.       ELSE IF (STRING(1:1) .EQ. 'E') THEN
  184. C
  185. C ----- 'END' COMMAND
  186. C
  187.          ISTART = NUM - 21
  188.          IF (ISTART .LE. 0)ISTART = 1
  189.          IF (NUM .EQ. 0 )ISTART = 0
  190.          CALL WRITA ( NWRITE, NUM, IARRAY, ISTART )
  191.          IPTR = NUM
  192.          IY = MIN0 ( NUM+1, 23 )
  193.          IF (NUM .EQ. 0) IY = 2
  194.          CALL GOTOXY ( NWRITE, IX, IY )
  195. C
  196.       ELSE IF (STRING(1:1) .EQ. 'I') THEN
  197. C
  198. C ----- 'INSERT' COMMAND
  199. C
  200.          IF (NUM .EQ. MAX) THEN
  201.             CALL MBELL ( NWRITE )
  202.             CALL STAT ( IX, IY, ' Arrays full, insert ignored. ' )
  203.             CALL WAIT ( 3 )
  204.             CALL NSTAT ( IX, IY, NUM, DOWN )
  205.          ELSE
  206.             IF (IPTR .LE. NUM) THEN
  207.                DO 120 II = NUM, IPTR, -1
  208.                   IARRAY(II+1) = IARRAY(II)
  209. 120               CONTINUE
  210.                IARRAY(IPTR) = 0
  211.             ELSE
  212.                IARRAY(NUM+1) = 0
  213.             ENDIF
  214.             NUM = NUM + 1
  215.             CALL NSTAT ( IX, IY, NUM, DOWN )
  216.             CALL WRITA ( NWRITE, NUM, IARRAY, ISTART )
  217.             CALL GOTOXY ( NWRITE, IX, IY )
  218.          ENDIF
  219. C
  220.       ELSE IF (STRING(1:1) .EQ. 'Q') THEN
  221.          GO TO 1000
  222. C
  223.       ELSE IF (STRING(1:1) .EQ. 'R') THEN
  224. C
  225. C ----- 'REPAINT' SCREEN
  226. C
  227.          CALL WRITA ( NWRITE, NUM, IARRAY, ISTART )
  228.          CALL GOTOXY ( NWRITE, IX, IY )
  229. C
  230.       ELSE IF (STRING(1:1) .EQ. 'S') THEN
  231. C
  232. C ----- 'SCROLL' DIRECTION TOGGLE
  233. C
  234.          DOWN = .NOT. DOWN
  235.          CALL NSTAT ( IX, IY, NUM, DOWN )
  236.          CALL GOTOXY ( NWRITE, IX, IY )
  237. C
  238.       ELSE IF ((STRING(1:1) .EQ. '?') .OR. (STRING(1:1) .EQ. 'H')) THEN
  239. C
  240. C ----- 'HELP' COMMAND
  241. C
  242.          CALL CLEAR
  243.          WRITE ( NWRITE, 910 )
  244.          READ ( NREAD, 920 )
  245.          CALL CLEAR
  246.          CALL NSTAT ( IX, IY, NUM, DOWN )
  247.          CALL WRITA ( NWRITE, NUM, IARRAY, ISTART )
  248.          CALL GOTOXY ( NWRITE, IX, IY )
  249.       ELSE
  250. C
  251. C ----- INPUT LINE
  252. C
  253.          IF ( LENGTH(STRING) .EQ. 0 ) THEN
  254. C
  255. C -------- POSITION CURSOR ONLY
  256. C
  257.             IF ( DOWN ) THEN
  258.                IF ( IPTR .LT. NUM ) THEN
  259.                   IPTR = IPTR + 1
  260.                   IY = IY + 1
  261.                   IF ( IY .GT. 23 ) THEN
  262. C
  263. C  --------------  SCROLL UP
  264. C
  265.                      IY = 23
  266.                      ISTART = ISTART + 1
  267.                      CALL WRITL ( NWRITE, IY+1, IPTR, IARRAY )
  268.                      WRITE ( NWRITE, 940 )
  269.                      CALL REVLF ( NWRITE )
  270.                   ENDIF
  271.                ELSE
  272.                   CALL REVLF ( NWRITE )
  273.                ENDIF
  274.             ELSE
  275.                IF ( IPTR .GT. 1 ) THEN
  276.                   IPTR = IPTR - 1
  277.                   IY = IY - 1
  278.                   IF (IY .LT. 2 ) THEN
  279. C
  280. C  --------------  DOWN SCROLL
  281. C
  282.                      IY = 2
  283.                      ISTART = IPTR
  284.                      CALL GOTOXY ( NWRITE, IX, IY )
  285.                      WRITE ( NWRITE, 930 ) ESC
  286.                      CALL WRITL ( NWRITE, IY, IPTR, IARRAY )
  287.                   ENDIF
  288.                ENDIF
  289.                CALL GOTOXY ( NWRITE, IX, IY )
  290.             ENDIF
  291.          ELSE
  292. C
  293. C ------ MODIFY LINE
  294. C
  295.             IL = 1
  296.             IA = 0
  297. 200         CALL GETOKE ( STRING, 80, IL, TOKE, TYPE, ERR )
  298.             IF ( TYPE .EQ. 'E' ) THEN
  299.                CALL WRITL ( NWRITE, IY, IPTR, IARRAY )
  300.                GO TO 100
  301.             ENDIF
  302.             IF (( TYPE .NE. 'I' ) .OR. ERR ) THEN
  303.                CALL MBELL ( NWRITE )
  304.                CALL STAT ( IX, IY, ' Unintelligible input. ' )
  305.                CALL WAIT ( 3 )
  306.                CALL NSTAT ( IX, IY, NUM, DOWN )
  307.                CALL WRITL ( NWRITE, IY, IPTR, IARRAY )
  308.                GO TO 100
  309.             ENDIF
  310.             IA = IA + 1
  311.             IF ( IA .GT. NARRAY ) THEN
  312.                CALL MBELL ( NWRITE )
  313.                CALL STAT ( IX, IY, ' Extra data on line ignored. ' )
  314.                CALL WAIT ( 3 )
  315.                CALL NSTAT ( IX, IY, NUM, DOWN )
  316.                CALL WRITL ( NWRITE, IY, IPTR, IARRAY )
  317.                GO TO 100
  318.             ENDIF
  319. C
  320. C -------  PUT NEW VALUE IN ARRAY
  321. C
  322.             CALL RIGHT ( TOKE )
  323.             READ ( TOKE, 950 ) IARRAY ( IPTR )
  324.             GO TO 200
  325.          ENDIF
  326.       ENDIF
  327.       GO TO 100
  328. C
  329. C --- END REPEAT UNTIL
  330. C
  331. 1000  CALL SRESET ( NWRITE )
  332.       CALL CLEAR
  333.       RETURN
  334. 900   FORMAT ( A80 )
  335. 910   FORMAT (///,' A command is a line with a single letter on it :',/,
  336.      $ '    A)dd     - add a blank line to the end of the arrays',/,
  337.      $ '    B)egin   - go to the beginning of the arrays',/,
  338.      $ '    D)elete  - delete the current line',/,
  339.      $ '    E)nd     - go to the end of the arrays',/,
  340.      $ '    I)nsert  - insert a line before the indicated line',/,
  341.      $ '    Q)uit    - exit the editor',/,
  342.      $ '    R)epaint - repaint the screen',/,
  343.      $ '    S)croll  - change the direction of scrolling',/,
  344.      $ '    ? - produce this message',///,
  345.      $ ' Any other line is expected to be data.  Enter ^Z (control/Z)',
  346.      $ /,'  to exit the editor.',//,
  347.      $ ' Enter <CR> to continue.')
  348. 920   FORMAT ( A )
  349. 930   FORMAT ('+',A1,'M',$ )
  350. 940   FORMAT ( / )
  351. 950   FORMAT ( 10X,I10 )
  352.       END
  353. C
  354. C---END NAE
  355. C
  356.